home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
PROGSCAL
/
TBUTIL2.LZH
/
INPUT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1983-03-08
|
7KB
|
331 lines
{$debug-}
program in_put(input,output,outfile);
var
outfile : text;
number : string (6);
inline : lstring (255);
hold : lstring (255);
done : boolean;
count : word;
inkey : char;
special : boolean;
on_entry: boolean;
reshow : boolean;
value
done := false;
on_entry := true;
count := 0;
number := '000001';
inline := null;
hold := null;
const
f1 = chr (59);
f2 = chr (60);
f10 = chr (68);
bs = chr (08);
left = chr (75);
rc = chr (13);
procedure csrloc (x: word);
external;
procedure chrget (var x: word);
external;
procedure next_key;
var [static]
x : word;
lo : byte;
hi : byte;
begin
chrget (x);
lo := lobyte (x);
hi := hibyte (x);
if lo = 0 then
begin
special := true;
inkey := chr (hi);
end
else
begin
special := false;
inkey := chr (lo);
end;
end;
procedure clear_line;
var [static]
blanks79 : string (79);
first : boolean;
i : word;
value
first := true;
begin
if first then
begin
first := false;
for i := 1 to 79 do
blanks79 [i] := ' ';
end;
csrloc (6144);
write (blanks79);
csrloc (6144);
end;
procedure show_so_far_after_clear;
begin
if on_entry then
write (number,'=',inline)
else
write ('Enter new page number : ',inline);
end;
procedure show_so_far;
begin
clear_line;
show_so_far_after_clear;
end;
procedure strip_blanks;
var [static]
i : word;
begin
if (inline.len > 0) and (inline[1] = ' ') then
reshow := true
else
reshow := false;
{ strip leading blanks }
while (inline.len > 0) and then (inline [1] = ' ') do
begin
for i := 2 to inline.len do
inline [i-1] := inline [i];
inline.len := inline.len - 1;
end;
{ strip trailing blanks }
while (inline.len > 0) and then (inline [inline.len] = ' ') do
inline.len := inline.len - 1;
end;
procedure digest_number;
var [static]
all_numeric : boolean;
i : word;
j : word;
begin
strip_blanks;
if inline = null then
begin
number := '000001';
return;
end;
all_numeric := true;
for i := 1 to inline.len do
if not (inline [i] in ['0'..'9']) then
begin
all_numeric := false;
break;
end;
if all_numeric then
begin
number := '000000';
for i := 6 downto 1 do
begin
if inline.len < (7-i) then
break
else
number [i] := inline [inline.len + i - 6];
end;
end
else
begin
number := ' ';
if inline.len < 6 then
j := inline.len
else
j := 6;
for i := 1 to j do
number [i] := inline [i];
end;
end;
procedure increment;
var [static]
i : word;
j : word;
carry : boolean;
begin
i := 7;
for j := 6 downto 2 do
if number [j] = ' ' then
i := j
else
break;
repeat
carry := false;
i := i - 1;
if i = 0 then
return;
if number [i] in ['0'..'9'] then
if number [i] = '9' then
begin
number [i] := '0';
carry := true;
end
else
number [i] := chr (1 + ord (number [i]))
else
begin
for j := 6 downto (i+2) do
number [j] := number [j-1];
if i < 6 then
number [i+1] := '1';
end;
until not carry;
end;
procedure initialize;
var [static]
i : word;
begin
rewrite (outfile);
for i := 1 to 25 do
writeln;
writeln ('Index data entry program (C) Copyright Peter Norton 1983');
writeln;
writeln ('Function keys : f1 - enter new page number');
writeln (' f2 - increment page number');
writeln (' f10 - end operation');
writeln;
writeln (' Page = Index entry description');
writeln ('______ _____________________________________________________');
show_so_far;
end;
procedure process_rc;
begin
if on_entry then
begin
strip_blanks;
if inline.len = 0 then
return;
count := count + 1;
if reshow then
show_so_far;
writeln (outfile,number,'=',inline);
writeln;
if special and (inkey = f10) then
return;
inline := null;
show_so_far_after_clear;
end
else
begin
on_entry := true;
digest_number;
inline := hold;
show_so_far;
end;
end;
procedure process_f10;
begin
if on_entry and (inline.len > 0) then
process_rc;
done := true;
end;
procedure process_regular;
begin
if inline.len > 71 then
begin
write (chr(7));
return;
end;
inline.len := inline.len + 1;
inline [inline.len] := inkey;
write (inkey);
end;
procedure process_invalid_special;
begin
clear_line;
writeln;
writeln ('Special key ignored.');
writeln;
write (chr(7));
show_so_far;
end;
procedure process_f1;
begin
if not on_entry then
begin
process_invalid_special;
return;
end;
on_entry := false;
hold := inline;
inline := null;
show_so_far;
end;
procedure process_f2;
begin
if not on_entry then
begin
process_invalid_special;
return;
end;
increment;
show_so_far;
end;
procedure process_bs;
begin
if inline.len > 0 then
begin
inline.len := inline.len - 1;
write (bs,' ',bs);
end
else
show_so_far;
end;
procedure process_input;
begin
next_key;
if special then
case inkey of
f1: process_f1;
f2: process_f2;
f10: process_f10;
left: process_bs;
otherwise process_invalid_special;
end
else
case inkey of
rc: process_rc;
bs: process_bs;
otherwise process_regular;
end;
end;
procedure finish_up;
begin
close (outfile);
writeln;
writeln (count,' index entries written.');
end;
begin
initialize;
repeat
process_input
until done;
finish_up;
end.